home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Canvas.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  10.0 KB  |  339 lines
  1. ;;;;
  2. ;;;; C a n v a s . s t k       --  Canvas class definition
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  15. ;;;;    Creation date: 18-Aug-1993 19:55
  16. ;;;; Last file update: 23-Jul-1996 10:39
  17.  
  18. (require "Basics")
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;;;;
  22. ;;;; Canvas class definition
  23. ;;;;
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. (define-class <Canvas> (<Tk-simple-widget> <Tk-sizeable> <Tk-xyscrollable> 
  26.             <Tk-editable> <Tk-selectable>)
  27.  
  28.   ((items            :initform    (make-hash-table))
  29.    (close-enough       :init-keyword    :close-enough
  30.                :accessor    close-enough
  31.                :tk-name        closeenough
  32.                :allocation    :tk-virtual)
  33.    (confine            :init-keyword    :confine
  34.                :accessor    confine
  35.                :allocation    :tk-virtual)
  36.    (x-scroll-increment :init-keyword    :x-scroll-increment
  37.                :accessor    x-scroll-increment
  38.                :tk-name        xscrollincrement
  39.                :allocation     :tk-virtual)
  40.    (y-scroll-increment :init-keyword    :y-xscroll-increment
  41.                :accessor    y-scroll-increment
  42.                :tk-name        yscrollincrement
  43.                :allocation     :tk-virtual)
  44.    (scroll-region      :init-keyword    :scroll-region
  45.                :accessor    scroll-region
  46.                :tk-name        scrollregion
  47.                :allocation    :tk-virtual)))
  48.  
  49. (define-method tk-constructor ((self <Canvas>))
  50.   Tk:canvas)
  51.  
  52. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53. ;;;;
  54. ;;;; Utilities
  55. ;;;;
  56. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57.  
  58.  
  59. ;; tag-value delivers the integer Id of an object. A method for canvas items 
  60. ;; will be defined later
  61. (define-method tag-value ((object <top>))
  62.   (if (or (symbol?  object) (integer? object) (string?  object))
  63.       object
  64.       (error "**** object ~A is not contained in a canvas" object)))
  65.  
  66.  
  67. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  68. ;;;;
  69. ;;;; <Canvas> methods
  70. ;;;;
  71. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72.  
  73. ;;;
  74. ;;; Add-tag
  75. ;;;
  76. (define-method add-tag ((self <Canvas>) tag . args)
  77.   (apply (slot-ref self 'Id) 'addtag tag args))
  78.  
  79. ;;;
  80. ;;; Bounding-box
  81. ;;;
  82. (define-method bounding-box ((self <Canvas>) tag)
  83.   ((slot-ref self 'Id) 'bbox (tag-value tag)))
  84.  
  85. ;;;
  86. ;;; Bind
  87. ;;;
  88. (define-method bind ((self <Canvas>) tag-or-Id . args)
  89.   (if (and (string? tag-or-Id) 
  90.        (> (string-length tag-or-Id) 2)
  91.        (eq? (string-ref tag-or-Id 0) #\<))
  92.       (apply bind (slot-ref self 'Id) tag-or-Id args)
  93.       (apply (slot-ref self 'Id) 'bind  (tag-value tag-or-Id) args)))
  94.  
  95. ;;;
  96. ;;; Canvas-x
  97. ;;;
  98. (define-method canvas-x ((self <Canvas>) screenx . args)
  99.   (apply (slot-ref self 'Id) 'canvasx screenx args))
  100.  
  101. ;;;
  102. ;;; Canvas-y
  103. ;;;
  104. (define-method canvas-y ((self <Canvas>) screeny . args)
  105.   (apply (slot-ref self 'Id) 'canvasy screeny args))
  106.  
  107. ;;;
  108. ;;; Coords et (setter coords)
  109. ;;;
  110. (define-method coords ((self <Canvas>) tag-or-Id)
  111.   ((slot-ref self 'Id) 'coords (tag-value tag-or-Id)))
  112.  
  113. (define-method (setter coords) ((self <Canvas>) tag-or-Id  args)
  114.   (apply (slot-ref self 'Id) 'coords (tag-value tag-or-Id) args))
  115.  
  116. ;;;
  117. ;;; Delete-chars
  118. ;;;
  119. (define-method delete-chars ((self <Canvas>) tag-or-Id first . last)
  120.   (apply (slot-ref self 'Id) 'dchars (tag-value tag-or-Id) first last))
  121.  
  122. ;;;
  123. ;;; Delete (BUG. This procedure doesn't clean the hash table).....
  124. ;;;
  125. (define-method canvas-delete ((self <Canvas>) . args)
  126.   (apply (slot-ref self 'Id) 'delete (map tag-value args)))
  127.  
  128. ;;;
  129. ;;; Delete-tag
  130. ;;;
  131. (define-method delete-tag ((self <Canvas>) tag-or-Id . tag-to-delete)
  132.   (apply (slot-ref self 'Id) 'dtag (tag-value tag-or-Id) tag-to-delete))
  133.  
  134.  
  135. ;;;
  136. ;;; Find-items
  137. ;;;
  138. (define-method find-items ((self <Canvas>) . args)
  139.   (let ((result (apply (slot-ref self 'Id) 'find args)))
  140.     (if (list? result)
  141.         (map (lambda (x) (Cid->instance self x)) result)
  142.         (Cid->instance self result))))
  143.  
  144. ;;;
  145. ;;; Focus
  146. ;;;
  147. (define-method item-with-focus ((self <Canvas>))
  148.   (Cid->instance self ((slot-ref self 'Id) 'focus)))
  149.  
  150. (define-method focus ((self <Canvas>) tag-or-id)
  151.   ((slot-ref self 'Id) 'focus (tag-value tag-or-id)))
  152.  
  153. ;;;
  154. ;;; Get-tags
  155. ;;;
  156. (define-method get-tags ((self <Canvas>) tag-or-Id)
  157.   ((slot-ref self 'Id) 'gettags (tag-value tag-or-Id)))
  158.  
  159. ;;;
  160. ;;; Icursor
  161. ;;;
  162. (define-method icursor ((self <Canvas>) tag-or-id index)
  163.   ((slot-ref self 'Id) 'icursor (tag-value tag-or-Id) index))
  164.  
  165. ;;;
  166. ;;; Index
  167. ;;;
  168. (define-method text-index ((self <Canvas>) tag-or-id index)
  169.   ((slot-ref self 'Id) 'index (tag-value tag-or-Id) index))
  170.  
  171. ;;;
  172. ;;; Insert
  173. ;;;
  174. (define-method text-insert ((self <Canvas>) tag-or-id before string)
  175.   ((slot-ref self 'Id) 'insert  (tag-value tag-or-Id) before string))
  176.  
  177.  
  178. ;;;
  179. ;;; Item-configure
  180. ;;;
  181. (define-method item-configure ((self <Canvas>) tag-or-id . args )
  182.   (apply (slot-ref self 'Id) 'itemconfigure (tag-value tag-or-Id) args))
  183.  
  184. ;;;
  185. ;;; Lower
  186. ;;; 
  187. (define-method lower ((self <Canvas>) tag-or-Id . below)
  188.   (apply (slot-ref self 'Id) 'lower (tag-value tag-or-Id) (map tag-value below)))
  189.  
  190. ;;;
  191. ;;; Move
  192. ;;;
  193. (define-method move ((self <Canvas>) tag-or-Id x y)
  194.   ((slot-ref self 'Id) 'move (tag-value tag-or-Id) x y))
  195.  
  196. ;;;
  197. ;;; Postscript
  198. ;;;
  199. (define-method postscript ((self <Canvas>) . args)
  200.   (apply (slot-ref self 'Id) 'postscript args))
  201.  
  202. ;;;
  203. ;;; Raise
  204. ;;;
  205. (define-method raise ((self <Canvas>) tag-or-Id . above)
  206.   (apply (slot-ref self 'Id) 'raise (tag-value tag-or-Id) (map tag-value above)))
  207.  
  208. ;;;
  209. ;;; Rescale
  210. ;;;
  211. (define-method rescale ((self <Canvas>) tag-or-Id x y xs ys)
  212.   ((slot-ref self 'Id) 'scale (tag-value tag-or-Id) x y xs ys))
  213.  
  214. ;;;
  215. ;;; Scan
  216. ;;;
  217. (define-method scan ((self <Canvas>) option x y)
  218.   ((slot-ref self 'Id) 'scan option x y))
  219.  
  220. ;;;
  221. ;;; Text-selection
  222. ;;;
  223. (define-method text-selection ((self <Canvas>) . args)
  224.   (apply (slot-ref self 'Id) 'select args))
  225.  
  226. ;;;;;; item-type can be obtained by (class-name(class-of xxx))
  227.  
  228. ;;;
  229. ;;; x-view family
  230. ;;;
  231. (define-method x-view ((self <Canvas>) . args)
  232.   (apply (slot-ref self 'Id) 'xview args))
  233.  
  234. (define-method x-view-scroll-units((self <Canvas>) num)
  235.   ((slot-ref self 'Id) 'xview 'scroll num 'units))
  236.  
  237. (define-method x-view-scroll-pages((self <Canvas>) num)
  238.   ((slot-ref self 'Id) 'xview 'scroll num 'pages))
  239.  
  240. (define-method x-view-moveto((self <Canvas>) fraction)
  241.   ((slot-ref self 'Id) 'xview 'moveto fraction))
  242.  
  243. ;;;
  244. ;;; y-view family
  245. ;;;
  246. (define-method y-view ((self <Canvas>) . args)
  247.   (apply (slot-ref self 'Id) 'yview args))
  248.  
  249. (define-method y-view-scroll-units((self <Canvas>) num)
  250.   ((slot-ref self 'Id) 'yview 'scroll num 'units))
  251.  
  252. (define-method y-view-scroll-pages((self <Canvas>) num)
  253.   ((slot-ref self 'Id) 'yview 'scroll num 'pages))
  254.  
  255. (define-method y-view-moveto((self <Canvas>) fraction)
  256.   ((slot-ref self 'Id) 'yview 'moveto fraction))
  257.  
  258. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  259. ;;;;
  260. ;;;; bind-for-dragging
  261. ;;;;
  262. :;;; You can specify a :start, :before-motion, :after-motion, and :stop scripts
  263. ;;;; If :before-motion returns #f the the object is not displaced and the
  264. ;;;; :after-motion closure is not applied.
  265. ;;;;
  266. ;;;; Old :motion hook is equivalent to :after-motion but its use is deprecated
  267. ;;;;
  268. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  269.  
  270. (define-generic bind-for-dragging)
  271. (let ()
  272.   (define last-x            0)
  273.   (define last-y            0)
  274.   (define instance-selected '())
  275.  
  276.   (define (start-drag instance x y closure tag)
  277.     (let ((tag (or tag (car ((slot-ref instance 'Id) 'find 'with 'current)))))
  278.       (delete-tag instance 'selected)
  279.       (add-tag instance 'selected 'with tag)
  280.       (raise instance 'selected)
  281.       (set! last-x x)
  282.       (set! last-y y)
  283.       (set! instance-selected (Cid->instance instance tag))
  284.       ;; Apply user :start hook
  285.       (if closure
  286.       (closure instance-selected x y))))
  287.   
  288.   (define (motion-drag instance x y before after)
  289.     (let ((continue #t))
  290.       ;; Apply user :before-motion hook
  291.       (if before 
  292.       (set! continue (before instance-selected x y)))
  293.       (when continue 
  294.     (move instance 'selected (- x last-x) (- y last-y))
  295.     (set! last-x x)
  296.     (set! last-y y)
  297.     ;; Apply user :after-motion hook
  298.     (if after 
  299.         (after instance-selected x y)))))
  300.  
  301.   (define (fast-motion-drag instance x y)
  302.     (move instance 'selected (- x last-x) (- y last-y))
  303.     (set! last-x x)
  304.     (set! last-y y))
  305.   
  306.   (define (stop-drag instance x y closure)
  307.     (delete-tag instance 'selected)
  308.     ;; Apply user :stop hook
  309.     (if closure 
  310.     (closure instance-selected x y)))
  311.  
  312.   (add-method bind-for-dragging (method ((self <Canvas>) . args)
  313.     (let* ((Id     (slot-ref self 'Id))
  314.        (who    (tag-value (get-keyword :tag args 'all)))
  315.        (but    (get-keyword :button args 1))
  316.        (mod    (get-keyword :modifier args ""))
  317.        (alone  (get-keyword :only-current args #t)) 
  318.        (str    (if (equal? mod "") "" (string-append mod "-")))
  319.        (start  (get-keyword :start args #f))
  320.        (before (get-keyword :before-motion args #f))
  321.        (after  (get-keyword :after-motion args (get-keyword :motion args #f)))
  322.        (stop   (get-keyword :stop args #f)))
  323.       
  324.       ;; Start binding
  325.       (bind self who (format #f "<~AButtonPress-~A>" str but) 
  326.         (lambda (x y) (start-drag self x y start (if alone #f who))))
  327.       ;; Motion binding
  328.       (bind self who (format #f "<~AB~A-Motion>" str but)
  329.         (if (or before after)
  330.         (lambda (x y) (motion-drag self x y before after))
  331.         ;; Provide a faster motion handler
  332.         (lambda (x y) (fast-motion-drag self x y))))
  333.       ;; Stop binding
  334.       (bind self who (format #f "<~AButtonRelease-~A>" str but)
  335.         (lambda (x y) (stop-drag self x y stop)))))))
  336.  
  337. (require "Canvitem")
  338. (provide "Canvas")
  339.